(SETQ IBASE (ADD1 7)) 


(DEFPROP SDIO 
 (NIL SDIOSET
      SDIOINIT
      IN
      OUT
      CH
      QCH
      UNCH
      SPWD
      *NIL*
      $PDLSIZE
      TOP
      STK0
      STK1
      STK2
      STK3
      STK4
      STK5
      OUTPDL
      OUTBKU
      START
      FUNFLAT
      DOPRINT
      FPRINT
      FSIZE
      SPACING
      SPACES
      OTST
      OUTTST
      <ATOM>
      <ID>
      <NUMBER>
      <CHAR>
      <UNARY_OP>
      FCALL
      >ATOM<
      >ID<
      RESERVEDWORDS
      >NUMBER<
      >CHAR<) 
VALUE)

(DEFPROP SDIOSET 
 (LAMBDA NIL
  (PROG NIL
	(SETQ SCNVAL NIL)
	(*PUTSYM (QUOTE SCNVAL) (GET (QUOTE SCNVAL) (QUOTE VALUE)))
	(PUTSYM (TRUTH (QUOTE T)) (NILX (QUOTE *NIL*)) (STAR (QUOTE *))))) 
EXPR)

(DEFPROP SDIOINIT 
 (LAMBDA NIL
  (PROG NIL
	(SETQ %%NIL (MAKNAM (QUOTE (N I L))))
	(GETSYM SUBR
 		ATM
    XXTRY 
 		SCANINIT
 		LETTER
 		IGNORE
 		SCAN
 		SCANSET
 		SCANRESET
 		CHX
 		SPWDX
 		REDUCE
 		STK
 		PPOS
 		PDLSET
 		LOC
 		FLATC
 		NLRR
 		LRR
 		OUTRUL
 		MATCH)
	(SCANINIT 176 12 42 42 45)
	(IGNORE 12)
	(IGNORE 175)
	(IGNORE 11)
	(IGNORE 15)
	(IGNORE 40)
	(LETTER 30)
	(SETQ MAXLNG 105)
	(SETQ FOOBAZ (LIST (QUOTE :CH) (INTERN (ASCII 0))))
	(DEFPROP >ATOM< ((>ATOM< . 1)) SPACING)
	(INITFN (FUNCTION SCANRESET)))) 
EXPR)

(DEFPROP IN 
 (LAMBDA (L) (PROG (X) (SCANSET) (START) (SETQ X (EVAL L)) (SCANRESET) (RETURN (COND (X (TOP)) (*NIL*))))) 
FEXPR)

(DEFPROP OUT 
 (LAMBDA(%%L)
  (PROG NIL (SETQ &&Z (FUNFLAT (LIST (LIST (OUTTST (EVAL (CADR %%L)) (CAR %%L)))))) (OTST MAXLNG))) 
FEXPR)

(DEFPROP CH 
 (LAMBDA (L) (LIST (QUOTE CHX) (UNCH (CADR L)))) 
MACRO)

(DEFPROP QCH 
 (LAMBDA (L) (LIST (QUOTE CHX) (UNCH (CADR L)))) 
MACRO)

(DEFPROP UNCH 
 (LAMBDA (X) (LSH (MAKNUM (CAAR (GET X (QUOTE PNAME))) (QUOTE FIXNUM)) -13)) 
EXPR)

(DEFPROP SPWD 
 (LAMBDA (L) (LIST (QUOTE SPWDX) (CONS (QUOTE QUOTE) (CDR L)))) 
MACRO)

(DEFPROP *NIL* 
 (NIL . *NIL*) 
VALUE)

(DEFPROP $PDLSIZE 
 (NIL . 1000) 
VALUE)

(DEFPROP TOP 
 (LAMBDA NIL (PDL 4)) 
EXPR)

(DEFPROP STK0 
 (LAMBDA NIL (STK 0)) 
EXPR)

(DEFPROP STK1 
 (LAMBDA NIL (STK 1)) 
EXPR)

(DEFPROP STK2 
 (LAMBDA NIL (STK 2)) 
EXPR)

(DEFPROP STK3 
 (LAMBDA NIL (STK 3)) 
EXPR)

(DEFPROP STK4 
 (LAMBDA NIL (STK 4)) 
EXPR)

(DEFPROP STK5 
 (LAMBDA NIL (STK 5)) 
EXPR)

(DEFPROP OUTPDL 
 (LAMBDA(N)
  (PROG NIL
   L    (COND ((MINUSP N) (RETURN (QUOTE BOTTOM))))
	(PRINT (CONS (PDL (PLUS N N 1)) (PDL (PLUS N N))))
	(SETQ N (SUB1 N))
	(GO L))) 
EXPR)

(DEFPROP OUTBKU 
 (LAMBDA(N)
  (PROG NIL
   L    (COND ((ZEROP N) (RETURN (QUOTE BOTTOM))))
	(PRINT (CONS (BACKUP (PLUS N N 1)) (BACKUP (PLUS N N))))
	(SETQ N (SUB1 N))
	(GO L))) 
EXPR)

(DEFPROP START 
 (LAMBDA NIL
  (PROG NIL
	(COND ((GET (QUOTE PDL) (QUOTE SUBR))) (T (ARRAY BACKUP T $PDLSIZE) (ARRAY PDL T $PDLSIZE)))
	(PDLSET (GET (QUOTE PDL) (QUOTE SUBR)) (GET (QUOTE BACKUP) (QUOTE SUBR)) (*QUO $PDLSIZE 2)))) 
EXPR)

(DEFPROP FUNFLAT 
 (LAMBDA(L)
  (PROG (FL FLP M S K)
	(SETQ S 0)
	(SETQ FL (SETQ FLP (CONS NIL L)))
   L0   (SETQ L (CDR FLP))
	(COND ((NULL L) (RPLACA FL S) (RETURN FL))
	      ((EQ (SETQ M (CAR L)) (QUOTE %DOWN)) (RPLACD FLP (SETQ L (CDR L)))
						   (COND ((ATOM (SETQ M (CAR L))) (SETQ K (FSIZE M)))
							 ((EQ (CAR M) (QUOTE :CH))
							  (SETQ K (ADD1 (SPACING LAST (CADR M)))))
							 (T (RPLACA L (FUNFLAT M)) (SETQ K (CAAR L)))))
	      ((ATOM M) (SETQ K (FSIZE M)))
	      ((EQ (CAR M) (QUOTE :CH)) (SETQ K (ADD1 (SPACING LAST (CADR M)))))
	      ((EQ (CAR M) (QUOTE %IN)) (SETQ K 0))
	      (T (RPLACD FLP M) (RPLACD (LAST M) (CDR L)) (GO L0)))
	(SETQ S (PLUS S K))
	(SETQ FLP (CDR FLP))
	(GO L0))) 
EXPR)

(DEFPROP DOPRINT 
 (LAMBDA(L)
  (COND ((ATOM L) (SPACES LAST (QUOTE >ATOM<)) (PRIN1 L))
	((EQ (CAR L) (QUOTE :CH)) (SPACES LAST (CADR L)) (PRINC (CADR L)))
	((EQ (CAR L) (QUOTE %IN)))
	(T (MAPC (FUNCTION DOPRINT) (CDR L))))) 
EXPR)

(DEFPROP FPRINT 
 (LAMBDA(L POS)
  (COND ((LESSP (PLUS (CAR L) POS) MAXLNG) (DOPRINT L))
	(T
	 (PROG NIL
 	  L    (SETQ L (CDR L))
	       (COND ((NULL L) (RETURN NIL))
		     ((ATOM (CAR L)) (DOPRINT (CAR L)))
		     ((AND (EQ (CAAR L) (QUOTE %IN)) (NUMBERP (CADAR L))) (PPOS (PLUS POS (CADAR L)))
									  (SETQ LAST (QUOTE >CR<)))
		     ((EQ (CAAR L) (QUOTE :CH)) (DOPRINT (CAR L)))
		     (T (FPRINT (CAR L) (LOC))))
	       (GO L))))) 
EXPR)

(DEFPROP FSIZE 
 (LAMBDA (X) (PLUS (FLATSIZE X) (SPACING LAST (QUOTE >ATOM<)))) 
EXPR)

(DEFPROP SPACING 
 (LAMBDA(OLD NEW)
  (PROG2 (SETQ LAST NEW)
	 (CDR (SASSOC NEW (GET OLD (QUOTE SPACING)) (FUNCTION (LAMBDA NIL (QUOTE (NIL . 0)))))))) 
EXPR)

(DEFPROP SPACES 
 (LAMBDA(OLD NEW)
  (PROG (N) (SETQ N (SPACING OLD NEW)) L (COND ((ZEROP N) (RETURN NIL))) (TYO 40) (SETQ N (SUB1 N)) (GO L))) 
EXPR)

(DEFPROP OTST 
 (LAMBDA (MAXLNG) (PROG NIL (TERPRI) (SETQ LAST NIL) (FPRINT &&Z 0) (TERPRI))) 
EXPR)

(DEFPROP OUTTST 
 (LAMBDA (X F) (PROG NIL (START) (SETQ LAST NIL) (STORE (PDL 2) X) (RETURN (F 0)))) 
EXPR)

(DEFPROP <ATOM> 
 (LAMBDA NIL (PROG2 (SCANRESET) (ATM) (SCANSET))) 
EXPR)

(DEFPROP <ID> 
 (LAMBDA NIL (%TRY 0)) 
EXPR)

(DEFPROP <NUMBER> 
 (LAMBDA NIL (%TRY 2)) 
EXPR)

(DEFPROP <CHAR> 
 (LAMBDA NIL (NLRR (QUOTE <CHAR>) (FUNCTION (LAMBDA NIL (COND ((%TRY 3) (INTERN (ASCII (STK 0)))) (*NIL*)))))) 
EXPR)

(DEFPROP <UNARY_OP> 
 (LAMBDA NIL NIL) 
EXPR)

(DEFPROP FCALL 
 (LAMBDA (L) (CDR L)) 
MACRO)

(DEFPROP >ATOM< 
 (LAMBDA (X) (OUTRUL X (FUNCTION (LAMBDA NIL (COND ((NULL (STK1)) (NCONS %%NIL)) ((ATOM (STK1)) (STK1))))))) 
EXPR)

(DEFPROP >ID< 
 (LAMBDA(X)
  (OUTRUL X
	  (FUNCTION
	   (LAMBDA NIL
	    (COND ((NUMBERP (STK1)) NIL)
		  ((MEMBER (STK1) RESERVEDWORDS) NIL)
		  ((NULL (STK1)) (NCONS NIL))
		  ((ATOM (STK1)) (STK1))))))) 
EXPR)

(DEFPROP RESERVEDWORDS 
 (NIL) 
VALUE)

(DEFPROP >NUMBER< 
 (LAMBDA (X) (OUTRUL X (FUNCTION (LAMBDA NIL (COND ((NUMBERP (STK1)) (STK1))))))) 
EXPR)

(DEFPROP >CHAR< 
 (LAMBDA (X) (OUTRUL X (FUNCTION (LAMBDA NIL (LIST (QUOTE :CH) (STK1)))))) 
EXPR)

(SDIOSET)